home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-cp-p.el.z / efs-cp-p.el
Encoding:
Text File  |  1998-05-21  |  4.9 KB  |  166 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-cp-p.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.1 $
  7. ;; RCS:          
  8. ;; Description:  Support for preserving file modtimes with copies. i.e. cp -p
  9. ;; Author:       Sandy Rutherford <sandy@ibm550.sissa.it>
  10. ;; Created:      Fri Feb 18 03:28:22 1994 by sandy on ibm550
  11. ;; Modified:     Sun Nov 27 12:17:33 1994 by sandy on gandalf
  12. ;; Language:     Emacs-Lisp
  13. ;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. ;;; This file is part of efs. See efs.el for copyright
  17. ;;; (it's copylefted) and warrranty (there isn't one) information.
  18.  
  19. (provide 'efs-cp-p)
  20. (require 'efs)
  21.  
  22. ;;;; Internal Variables
  23.  
  24. (defconst efs-cp-p-version
  25.   (concat (substring "$efs release: 1.15 $" 14 -2)
  26.       "/"
  27.       (substring "#Revision: 1.1 $" 11 -2)))
  28.  
  29. (defvar efs-local-timezone nil)
  30. ;; cache.
  31.  
  32. ;;; Utility functions
  33.  
  34. (efs-define-fun efs-gmt-time ()
  35.   ;; Get the time as the number of seconds elapsed since midnight,
  36.   ;; Jan 1, 1970, GMT.  Emacs 18 doesn't have `current-time' function.
  37.   (let ((time (current-time)))
  38.     (list (car time) (nth 1 time))))
  39.  
  40. (defun efs-local-time ()
  41.   (let ((str (current-time-string)))
  42.     (efs-seconds-elapsed
  43.      (string-to-int (substring str -4))
  44.      (cdr (assoc (substring str 4 7) efs-month-alist))
  45.      (string-to-int (substring str 8 10))
  46.      (string-to-int (substring str 11 13))
  47.      (string-to-int (substring str 14 16))
  48.      0))) ; don't care about seconds
  49.    
  50. (defun efs-local-timezone ()
  51.   ;; Returns the local timezone as an integer. Right two digits the minutes,
  52.   ;; others the hours.
  53.   (or efs-local-timezone
  54.       (setq efs-local-timezone
  55.         (let* ((local (efs-local-time))
  56.            (gmt (efs-gmt-time))
  57.            (sign 1)
  58.            (diff (efs-time-minus local gmt))
  59.            hours minutes)
  60.           ;; 2^16 is 36 hours.
  61.           (if (zerop (car diff))
  62.           (setq diff (nth 1 diff))
  63.         (error "Weird timezone!"))
  64.           (setq diff (/ (- (nth 1 local) (nth 1 gmt)) 60))
  65.           (setq hours (/ diff 60))
  66.           (setq minutes (% diff 60))
  67.           (if (< diff 0)
  68.           (setq sign -1
  69.             hours (- hours)
  70.             minutes (- minutes)))
  71.           ;; Round minutes
  72.           (setq minutes (* 10 (/ (+ minutes 5) 10)))
  73.           (if (= minutes 60)
  74.           (setq hours (1+ hours)
  75.             minutes 0))
  76.           (* sign (+ (* hours 100) minutes))))))
  77.         
  78. (defun efs-last-day-of-month (month year)
  79.   ;; The last day in MONTH during YEAR.
  80.   ;; Taken from calendar.el. Thanks.
  81.   (if (and
  82.        (or
  83.     (and (=  (% year   4) 0)
  84.          (/= (% year 100) 0))  ; leap-year-p
  85.     (= (% year 400) 0))
  86.        (= month 2))
  87.       29
  88.     (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
  89.  
  90. (defun efs-make-date-local (year month day hour minutes seconds)
  91.   ;; Takes a GMT date (list of integers), and returns the local time.
  92.   (let* ((lzone (efs-local-timezone))
  93.      (lminutes (% lzone 100))
  94.      (lhour (/ lzone 100)))
  95.     (setq minutes (+ minutes lminutes))
  96.     (cond ((> minutes 60)
  97.        (setq minutes (- minutes 60)
  98.          hour (1+ hour)))
  99.       ((< minutes 0)
  100.        (setq minutes (+ minutes 60)
  101.          hour (1- hour))))
  102.     (setq hour (+ lhour hour))
  103.     (if (or (< hour 0) (> hour 23))
  104.     (progn
  105.       (cond ((< hour 0)
  106.          (setq hour (+ hour 24)
  107.                day (1- day)))
  108.         ((> hour 23)
  109.          (setq hour (- hour 24)
  110.                day (1+ day))))
  111.       (if (or (zerop day) (> day
  112.                  (efs-last-day-of-month month year)))
  113.           (cond ((zerop day)
  114.              (setq month (1- month))
  115.              (if (zerop month)
  116.              (setq year (1- year)
  117.                    month 12))
  118.              (setq day (efs-last-day-of-month month year)))
  119.             ((> day (efs-last-day-of-month month year))
  120.              (setq month (1+ month)
  121.                day 1)
  122.              (if (= month 13)
  123.              (setq year (1+ year)
  124.                    month 1)))))))
  125.     (list year month day hour minutes seconds)))
  126.  
  127. ;;;; Entry function
  128.  
  129. (defun efs-set-mdtm-of (filename newname &optional cont)
  130.   ;; NEWNAME must be local
  131.   ;; Always works NOWAIT = 0
  132.   (let* ((parsed (efs-ftp-path filename))
  133.      (host (car parsed))
  134.      (user (nth 1 parsed))
  135.      (file (nth 2 parsed)))
  136.     (if (efs-get-host-property host 'mdtm-failed)
  137.     (and cont (efs-call-cont cont 'failed "" "") nil)
  138.       (efs-send-cmd
  139.        host user
  140.        (list 'quote 'mdtm file)
  141.        nil nil
  142.        (efs-cont (result line cont-lines) (host newname cont)
  143.      (if (or result
  144.          (not (string-match efs-mdtm-msgs line)))
  145.          (efs-set-host-property host 'mdtm-failed t)
  146.        (let ((time (apply 'efs-make-date-local
  147.                   (mapcar 'string-to-int
  148.                       (list
  149.                        (substring line 4 8)
  150.                        (substring line 8 10)
  151.                        (substring line 10 12)
  152.                        (substring line 12 14)
  153.                        (substring line 14 16)
  154.                        (substring line 16 18))))))
  155.          (if time
  156.          (call-process "touch" nil 0 nil "-t"
  157.                    (format "%04d%02d%02d%02d%02d.%02d"
  158.                        (car time) (nth 1 time)
  159.                        (nth 2 time) (nth 3 time)
  160.                        (nth 4 time) (nth 5 time))
  161.                    newname))))
  162.      (if cont (efs-call-cont cont result line cont-lines)))
  163.        0))))
  164.  
  165. ;;; end of efs-cp-p.el
  166.